home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / SIOD 3.0 / sql_rdb.scm < prev    next >
Encoding:
Text File  |  1994-09-12  |  2.8 KB  |  104 lines  |  [TEXT/ttxt]
  1. ;;-*-mode:lisp-*-
  2. ;; For use with the DIGITAL RDB SQL SERVICES interface to SIOD.
  3. ;; 20-JAN-94 GJC.
  4. ;;
  5. ;; Loading (into siod linked with sql_rdb.obj)
  6. ;;  $siod -g0 -isql_rdb.scm -h150000
  7. ;;
  8. ;; Procedures: (rdb-sql-init "database-name")
  9. ;;             (rdb-sql-error?) => last sql error
  10. ;;             (rdb-sql "string") => result of operation.
  11. ;;             (rdb-show-table "table-name") => column information.
  12. ;;             (rdb-show-tables) => list all tables.
  13.  
  14. (define *rdb-sql-association* nil)
  15. (define *rdb-sql-database* nil)
  16.  
  17. (define (rdb-sql-init db)
  18.   (if (null? *rdb-sql-association*)
  19.       (begin (set! *rdb-sql-association* (rdb-sql-associate))
  20.          (if db
  21.          (set! *rdb-sql-database* db))
  22.          (if *rdb-sql-database*
  23.          (rdb-sql-execute-immediate
  24.           *rdb-sql-association*
  25.           (string-append "declare schema filename "
  26.                  *rdb-sql-database*))))))
  27.  
  28. (define (rdb-sql-error?)
  29.   (rdb-sql-error-buffer *rdb-sql-association*))
  30.  
  31. (define (rdb-sql-cleanup release-associations?)
  32.   (let ((l (rdb-sql-associations)))
  33.     (while l
  34.       (let ((s (rdb-sql-association-statements (car l))))
  35.     (while s
  36.       (rdb-sql-release (car s))
  37.       (set! s (cdr s))))
  38.       (if release-associations?
  39.       (rdb-sql-release (car l)))
  40.       (set! l (cdr l)))))
  41.  
  42. (define (unwind-protected l1 l2)
  43.   (let ((x (*catch 'errobj (l1))))
  44.     (l2)
  45.     x))
  46.  
  47. (define (rdb-sql cmd)
  48.   (rdb-sql-init nil)
  49.   (let ((s nil)
  50.     (p nil)
  51.     (l nil)
  52.     (c nil)
  53.     (result nil)
  54.     (row nil)
  55.     (rowp nil)
  56.     (x nil))
  57.     (unwind-protected
  58.      (lambda ()
  59.        (set! s (rdb-sql-prepare-cached *rdb-sql-association* cmd))
  60.        (set! p (rdb-sql-statement-params s))
  61.        (set! l (rdb-sql-statement-selects s))
  62.        (if p (error "params not implemented"))
  63.        (if (null? l)
  64.        (set! result (rdb-sql-execute s))
  65.      (begin (rdb-sql-declare-cursor s 'table 'read-only)
  66.         (set! c (rdb-sql-open-cursor s))
  67.         (while (rdb-sql-fetch s)
  68.           (set! rowp l)
  69.           (set! row nil)
  70.           (while rowp
  71.             (set! row (cons (rdb-sql-get-column s
  72.                             (car (cdr (car rowp))))
  73.                     row))
  74.             (set! rowp (cdr rowp)))
  75.           (set! result (cons (nreverse row) result)))
  76.         (set! rowp l)
  77.         (set! row nil)
  78.         (while rowp
  79.           (set! row (cons (car (car rowp)) row))
  80.           (set! rowp (cdr rowp)))
  81.         (set! result (cons (nreverse row) (nreverse result)))))
  82.        result)
  83.      (lambda ()
  84.        (if c (rdb-sql-close-cursor s))
  85.        (if s (rdb-sql-release-cached s))))))
  86.  
  87. (define rdb-sql-prepare-cached rdb-sql-prepare)
  88. (define rdb-sql-release-cached rdb-sql-release)
  89.  
  90. (define (rdb-show-tables)
  91.   (rdb-sql "select rdb$relation_name,rdb$system_flag from rdb$relations"))
  92.  
  93. (define (rdb-show-table x)
  94.   (let ((s nil)
  95.     (l nil))
  96.     (unwind-protected
  97.      (lambda ()
  98.        (set! s (rdb-sql-prepare *rdb-sql-association*
  99.                 (string-append "select * from " x)))
  100.        (rdb-describe-statement s)
  101.        (set! l (rdb-sql-statement-selects s)))
  102.      (lambda ()
  103.        (and s (rdb-sql-release s))))))
  104.